Shareware Grab Bag

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Grab Bag / Shareware Grab Bag.iso / 008 / pccolor.bas (.txt) < prev next >

Wrap

GW-BASIC | 1985-06-10 | 7.3 KB | 240 lines

5 CLS:SCREEN 0,0,0:WIDTH 80:CLEAR:FOR I=1 TO 10:KEY I,"":NEXT:KEY 2,"GOTO 60"+CHR$(13):KEY 10,"RUN"+CHR$(34)+"BLUEMENU"+CHR$(34)+CHR$(13):LIST 10-57 12 '***************** COLOR PALETTES AND COLOR CHIPS ************************ 16 'KEYTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENCLOSE 18 'OPEN PC-COLOR PROGRAM DELUXE OPEN 20 'OPEN OPEN 22 'OPEN This program was keyed in from the November 1982 PC-Magazine. It OPEN 24 'OPEN was provided in an article entiled "Color Palettes and Color Chips" by OPEN 26 'OPEN Karl Koessell. The article started on page 305. The program allows OPEN 28 'OPEN users to test monitors before purchasing them. It checks the brilliance OPEN 30 'OPEN of the screen, and demonstrates the color combinations which are avail- OPEN 32 'OPEN able on the IBM-PC. It permits the viewer to determine the clarity and OPEN 34 'OPEN resolution of the WIDTH 80 presentation -- important if you plan to do OPEN 35 'OPEN extensive word-processing or detailed programming. This program has no OPEN 36 'OPEN commercial application and is provided as a service for personal use OPEN 37 'OPEN and color monitor evaluation. Author: Karl Koessell, address unknown. OPEN 38 'OPEN G I N A C O -- 1983 Ver 5.2/320k OPEN 50 'SCREENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENTHENLOAD 55 ' ***** < F2 > to RUN ******* < F10 > For BLUEMENU ***** 57 ' ====== To avoid DOCUMENTATION BOX each time, REM or DELETE line 5 ====== 60 CLS:SCREEN 0,0,0:WIDTH 80:CLEAR:FOR I=1 TO 10:KEY I,"":NEXT 100 KEY OFF 110 DEFINT A-Z 120 GOSUB 230 ' define pointers for function keys 130 FK=7 ' Initialize variables 140 PALETTE = 1 150 '* * * * MAIN LOOP * * * * * * * * * * 160 GOSUB 490 ' change display? 170 ' change background color or .... 180 IF SCR THEN GOSUB 1990 ELSE GOSUB 1210 '.. change border color 190 FOR PAUSE=1 TO 2000 'Pause a while 200 NEXT 210 GOTO 160 'Go thru main loop again 220 '************************************************************* 230 ON KEY(1) GOSUB 380 240 ON KEY(2) GOSUB 390 250 ON KEY(3) GOSUB 400 260 ON KEY(4) GOSUB 410 270 ON KEY(5) GOSUB 420 280 ON KEY(6) GOSUB 430 290 ON KEY(7) GOSUB 440 300 ON KEY(8) GOSUB 450 310 ON KEY(9) GOSUB 460 320 ON KEY(10) GOSUB 470 330 FOR FK=1 TO 10 ' Activate all 340 KEY(FK) ON ' ten function keys 350 NEXT 360 RETURN 370 '****** Flag FK set by function key 380 FK=1:RETURN 390 FK=2:RETURN 400 FK=3:RETURN 410 FK=4:RETURN 420 FK=5:RETURN 430 FK=6:RETURN 440 FK=7:RETURN 450 FK=8:RETURN 460 FK=9:RETURN 470 FK=10:RETURN 480 ' If FK, change display accordingly 490 ON FK GOSUB 520,600,640,640,690,740,790,880,970,1020 500 RETURN 510 '****** DISPLAYS AVAILABLE ******* 520 FK=0 'Toggle between screens 0 & 1 530 SCR = (SCR+1) MOD 2 540 ' Either prepare text mode or... 550 IF SCR=0 THEN GOSUB 790: RETURN 560 ' ... Prepare med. res. graphics mode 570 W=0 'Clear text mode flag 580 GOSUB 1560 590 RETURN 600 FK=0 'Change palette, graphics only 610 PALETTE=(PALETTE+1) MOD 2 620 GOSUB 2030 'Update palette info 630 RETURN 640 ON FK GOTO 680,650,640,670 ' PAUSE 650 GOSUB 490 ' Change display 660 GOTO 640 ' Still pausing 670 FK=0 'Continue background/border cycle 680 RETURN 690 FK=0 'Rowed foreground 700 IF RB=0 OR W=41 THEN RETURN 710 RB=0 'Clear rowed background flag 720 GOSUB 1300 'Print text display 730 RETURN 740 FK=0 'Rowed background 750 IF RB=1 OR W=41 THEN RETURN 760 RB=1 'Set rowed background 770 GOSUB 1300 780 RETURN 790 FK=0 'Width 40 text 800 IF W=1 THEN RETURN 810 WIDTH 40 820 W=1 'Flag set to middle of column 830 V=9 'First line of text 840 GOSUB 1080 'Prepare text mode 850 GOSUB 1240 'Update border information 860 GOSUB 1300 870 RETURN 880 FK=0 'Width 80 text 890 IF W=41 THEN RETURN 900 WIDTH 80 910 W=41 'Flag set to middle column 920 V=1 'First line of text 930 GOSUB 1080 940 GOSUB 1240 950 GOSUB 1300 960 RETURN 970 FK=0 'Standard characters 980 IF BLINK=0 THEN RETURN 990 BLINK=0 'CLEAR BLINKING FLAG 1000 GOSUB 1300 1010 RETURN 1020 FK=0 'Blinking Characters 1030 IF BLINK=1 THEN RETURN 1040 BLINK=1 'Set blinking flag 1050 GOSUB 1300 1060 RETURN 1070 '******** Text Mode *********** 1080 SCREEN 0,1,0,0 1090 FOR FK=5 TO 10 'Activate last six function keys 1100 KEY(FK) ON 1110 NEXT 1120 KEY(2) OFF 'Deactivate key 2 1130 COLOR 7,0 1140 CLS 1150 LOCATE ,8,0 1160 PRINT "COLOR TEXT (SCREEN 0,1,,)" 1170 PRINT 1180 GOSUB 2120 'Print instructions 1190 RETURN 1200 '********* Change Border Color ********** 1210 BORDER=(BORDER+1) MOD 16 1220 GOSUB 1240 1230 RETURN 1240 LOCATE 25,9+W/2 1250 COLOR BORDER,0,BORDER 1260 IF BORDER MOD 8=0 THEN COLOR ,7 1270 PRINT USING " Border is color _,_,## ";BORDER; 1280 RETURN 1290 '********* Print text display ************ 1300 LOCATE V,W 1310 IF RB=1 AND W=1 THEN 1390 1320 FOR F=0 TO 15 'Rowed background 1330 LOCATE V+F,W 1340 FOR B=0 TO 7 1350 GOSUB 1510 'Print text 1360 NEXT B,F 1370 IF W=1 THEN 1440 'Skip if WIDTH 40 1380 PRINT " "; 1390 FOR B=0 TO 7 'Rowed background 1400 FOR F=0 TO 15 1410 GOSUB 1510 'Print text 1420 NEXT F,B 1430 'Using monochrome display adapter 1440 DEF SEG=0 1450 IF (PEEK(1040) AND 48)=48 THEN 1490 'If so then all done, otherwise 1460 'color monitor needs a white space in last column of 24th monitor line 1470 DEF SEG=&HB800 1480 POKE 80*24*(1-1*(W=41))-1,64+32+16 1490 RETURN 1500 '********* Text printing routine ********* 1510 FG=F+16*BLINK 1520 COLOR FG,B 'SET NEW FORGROUND/BACKGROUND 1530 IF F=15 AND B=7 THEN PRINT "15,7";:GOTO 1550 1540 PRINT USING "##_,# ";FG;B; 1550 RETURN 1560 SCREEN 1,0,0,0 1570 FOR FK=5 TO 10 'Deactivate last six function keys 1580 KEY(FK) OFF 1590 NEXT 1600 KEY(2) ON 'Activate F2 key 1610 LOCATE ,5,0 1620 PRINT "MEDIUM RESOLUTION COLOR GRAPHICS" 1630 PRINT SPC(13)"(SCREEN 1,0,,)" 1640 GOSUB 2120 'Print instructions 1650 LOCATE 9,1 1660 PRINT "Changing palette changes" 1670 PRINT "the 4 foreground colors" 1680 PRINT "displayed at one time." 1690 FOR F=0 TO 3 'Boxes of color 1700 LOCATE 10+F*4,30 1710 PRINT F;"=" 1720 TOP=65+F*32 'Top line 1730 BOT=TOP+23 'Bottom line 1740 LINE (272,TOP)-(319,BOT),F,BF 1750 NEXT 1760 LOCATE 13,1 1770 PRINT "For the background and" 1780 PRINT "palette chosen by the" 1790 PRINT "statement COLOR " 1800 PRINT "a foreground number of {" 1810 LOCATE 18,1 1820 PRINT "Text (for SCREEN 1,0,,)" 1830 PRINT "is printed in foreground" 1840 PRINT "color 3, Text is invisible" 1850 PRINT "for COLOR 6,0 and COLOR 7,1" 1860 PRINT "and COLOR 14,0 and COLOR 15,1" 1870 LOCATE 24,12 1880 PRINT "Pallete is COLOR "; 1890 LOCATE 25,10 1900 PRINT "Background is COLOR "; 1910 FOR BRKT=25 TO 31 'Extend brackets 1920 LOCATE 40-BRKT,BRKT 1930 PRINT "/" 1940 LOCATE BRKT-8,BRKT 1950 PRINT "\" 1960 NEXT 1970 RETURN 1980 '********* Change Background Color ********* 1990 BACKGROUND=(BACKGROUND+1) MOD 16 2000 GOSUB 2030 2010 RETURN 2020 '********* Update background/palette info ******** 2030 LOCATE 15,17 2040 PRINT USING "##_,#";BACKGROUND,PALETTE 2050 LOCATE 24,29 2060 PRINT USING "##_, ";PALETTE; 2070 LOCATE 25,30 2080 PRINT USING "##_, ";BACKGROUND; 2090 COLOR BACKGROUND,PALETTE 2100 RETURN 2110 '******** Function Key Instructions ********** 2120 PRINT "[F1] = To Change Mode (TEXT or GRAPHICS)" 2130 IF SCR=0 THEN LOCATE 4,1:GOTO 2150 2140 PRINT SPC(19)"[F2] = Change Palette" 2150 PRINT "[F3] = To Pause "; 2160 IF SCR=0 THEN PRINT " "; 2170 PRINT "[F4] = To Continue" 2180 IF SCR THEN 2250 2190 IF W=41 THEN 2210 ' WIDTH 80 has both rowed foreground and rowed background 2200 PRINT "[F5] = Rowed Frgrnd [F6]= Rowed Bkgrnd" 2210 LOCATE 6,1 2220 PRINT "[F7] = WIDTH 40 [F8] = WIDTH 80" 2230 PRINT " Foreground chartacter choices:" 2240 PRINT "[F9] = Normal or [F10] = Blinking" 2250 RETURN 2260 END 65000 REM ===== SAVE ROUTINE ===== 65100 SAVE"B:PC-COLOR.BAS"